Power CD/Power CD ATARI-Rechner Lieben.iso/DEMOS/HM2_DEMO/BSP/MILLERFW.M

Text File | 1993-03-20 | 5.7 KB | 262 lines

MODULE Miller_f_Win;
(* Dieses Modul kann nur mit aktivierter Option f (Coprozessor) compiliert
     werden (sonst existiert das Pseudo-Modul FPU nicht). Ohne direkte Verwendung
     der FLine-FPU wäre das Programm zu langsam. *)

FROM FPU IMPORT SIN, COS, EXTEND, WHOLE;
IMPORT AES, appl, evnt, graf, MathLib0, VDI, v, vr, vs, vsf, vsl, wind;
FROM SYSTEM IMPORT ADR;

CONST
    cStep = 0.03;
    N = VAL (LONGINT, TRUNC (200.0 * MathLib0.pi / cStep + 0.5));

VAR
    hdl: SHORTINT;

PROCEDURE init(): BOOLEAN;

    TYPE
        tIn = ARRAY [0..10] OF SHORTINT;

    VAR
        in: tIn;
        out: ARRAY [0..56] OF SHORTINT;
        j: SHORTINT;

    BEGIN
        IF appl.init () < 0 THEN RETURN FALSE END;
        (*VDI init*)
        in := tIn{1 BY 10, 2};
        hdl := graf.handle (j, j, j, j);
        v.opnvwk (in, hdl, out);
        IF hdl > 0 THEN
            RETURN TRUE
        ELSE
            appl.exit;
            RETURN FALSE
        END;
    END init;

VAR
    wname: ARRAY [0..49] OF CHAR;

PROCEDURE intersect (VAR w1, w2: AES.tRect): BOOLEAN;

    VAR
        (*$Reg*) xmin, (*$Reg*) ymin,
        (*$Reg*) xmax, (*$Reg*) ymax,
        (*$Reg*) x2, (*$Reg*) y2: SHORTINT;

    BEGIN
        WITH w1 DO
            x2 := x+w;
            y2 := y+h;
            xmin := x;
            ymin := y;
        END;
        WITH w2 DO
            IF x > xmin THEN xmin := x END;
            IF y > ymin THEN ymin := y END;
            xmax := x+w; IF x2 < xmax THEN xmax := x2 END;
            ymax := y+h; IF y2 < ymax THEN ymax := y2 END;
            w2 := AES.tRect{xmin, ymin, xmax-xmin, ymax-ymin};
            RETURN ~((w <= 0) OR (h <= 0));
        END
    END intersect;

PROCEDURE Main;

    CONST
        cPoints = 100;

    TYPE
        tVRect = ARRAY [0..1] OF VDI.tPoint;

    VAR
        w2, h2: LONGINT;
        (*$Reg*) ox, (*$Reg*) oy: LONGINT;
        (*$Reg*) a,
        (*$Reg*) b,
        (*$Reg*) t: LONGREAL;
        (*$R+*) i: LONGINT;
        (*$Reg*) j: SHORTINT;
        Points: ARRAY [0..cPoints-1] OF VDI.tPoint;
        color: SHORTINT;
        wrect, desk: AES.tRect;
        fulled: BOOLEAN;
        FParam: wind.tFParam;
        w: SHORTINT;
        stop, resize, reset: BOOLEAN;

    PROCEDURE redraw (wrect: AES.tRect);

        VAR
            vrect: tVRect;
            rect: AES.tRect;

        BEGIN
            wind.update (wind.BegUpdate);
            IF intersect (desk, wrect) THEN
                v.hidec (hdl);
                wind.get (w, wind.FirstXYWH, rect);
                WHILE (rect.w > 0) & (rect.h > 0) DO
                    IF intersect (wrect, rect) THEN
                        WITH rect DO vrect := tVRect{{x,y},{x+w-1,y+h-1}} END;
                        vs.clip (hdl, TRUE, vrect);
                        vr.recfl (hdl, vrect);
                    END;
                    wind.get (w, wind.NextXYWH, rect);
                END;
                v.showc (hdl, FALSE);
            END;
            wind.update (wind.EndUpdate);
        END redraw;

    PROCEDURE draw (n: SHORTINT);

        CONST
            cMinW = 160;
            cMinH = 160;

        VAR
            msg: evnt.tMsg;
            event: BITSET;
            vrect: tVRect;
            rect: AES.tRect;

        BEGIN
            wind.update (wind.BegUpdate);
            v.hidec (hdl);
            wind.get (w, wind.FirstXYWH, rect);
            WHILE (rect.w > 0) & (rect.h > 0) DO
                IF intersect (desk, rect) THEN
                    WITH rect DO vrect := tVRect{{x,y},{x+w-1,y+h-1}} END;
                    vs.clip (hdl, TRUE, vrect);
                    v.pline (hdl, n, Points);
                END;
                wind.get (w, wind.NextXYWH, rect);
            END;
            v.showc (hdl, FALSE);
            wind.update (wind.EndUpdate);
            AES.intin[14] := 20;
            AES.intin[15] := 0;
            AES.addrin[0] := ADR (msg);
            event := evnt.pmulti ({evnt.Mesag, evnt.Timer});
            IF evnt.Mesag IN event THEN
                IF msg.win = w THEN
                    CASE msg.type OF
                    | evnt.Closed:
                            stop := TRUE;
                    | evnt.Topped:
                            FParam.handle := w;
                            wind.set (w, wind.Top, FParam.rect);
                    | evnt.Fulled:
                            IF fulled THEN
                                wind.get (w, wind.PrevXYWH, FParam.rect);
                                fulled := FALSE;
                            ELSE
                                wind.get (w, wind.FullXYWH, FParam.rect);
                                fulled := TRUE;
                            END;
                            wind.set (w, wind.CurrXYWH, FParam.rect);
                            resize := TRUE; reset := TRUE;
                    | evnt.Moved, evnt.Sized:
                            FParam.coord := msg.coord;
                            WITH FParam.coord DO
                                IF w < cMinW THEN w := cMinW END;
                                IF h < cMinH THEN h := cMinH END;
                            END;
                            wind.set (w, wind.CurrXYWH, FParam.rect);
                            resize := TRUE;
                            reset := msg.type = evnt.Sized;
                    | evnt.Redraw:
                            redraw (msg.coord);
                            VOID (vsl.color (hdl, VDI.Black));
                            color := VDI.Black;
                    END
                END
            END;
        END draw;

    BEGIN
        IF init() THEN
            graf.mouseform (graf.Arrow);
            wind.get (0, wind.WorkXYWH, desk);
            w := wind.create (
                 {wind.cName, wind.cClose, wind.cFull, wind.cMove, wind.cSize},
                 desk);
            wname := ' Miller - mit Hänisch Modula-2 programmiert ';
            FParam.string := ADR (wname);
            wind.set (w, wind.Name, FParam.rect);
            wrect := desk;
            WITH wrect DO
                w := w DIV 2;
                h := h DIV 2;
            END;
            fulled := FALSE;
            wind.open (w, wrect);
            VOID (vsf.color (hdl, VDI.White));
            color := VDI.Black;
            stop := FALSE; resize := TRUE; reset := FALSE;
            LOOP
                t := 0.0;
                VOID (vsl.color (hdl, color));
                j := 0;
                i := 0;
                WHILE i <= N DO
                    INC (i);
                    IF stop THEN EXIT END;
                    IF resize THEN
                        wind.get (w, wind.WorkXYWH, wrect);
                        WITH wrect DO
                            w2 := w DIV 2;
                            h2 := h DIV 2;
                            a := EXTEND (w2) / 2.0;
                            b := EXTEND (h2) / 1.3;
                            ox := x + w2;
                            oy := y + h2;
                        END;
                        resize := FALSE;
                        j := 0;
                    END;
                    IF reset THEN
                        wind.get (w, wind.WorkXYWH, wrect);
                        redraw (wrect);
                        VOID (vsl.color (hdl, VDI.Black));
                        color := VDI.Black;
                        j := 0; i := 0; t := 0.0;
                        reset := FALSE;
                    END;
                    INC (t, cStep);
                    Points[j] := VDI.tPoint{
                            ox + WHOLE (a * (SIN (0.99 * t) - 0.7 * COS (3.01 * t))),
                            oy + WHOLE (b * (COS (1.01 * t) + 0.1 * SIN (15.03 * t)))
                    };
                    INC (j);
                    IF j = cPoints THEN
                        draw (cPoints);
                        Points[0] := Points[cPoints-1];
                        j := 1
                    END
                END;
                IF j > 1 THEN
                    draw (j)
                END;
                IF color = VDI.Black THEN
                    color := VDI.White
                ELSE
                    color := VDI.Black
                END;
            END;
            wind.close (w);
            wind.delete (w);
            v.clsvwk (hdl);
            appl.exit ()
        END;
    END Main;

BEGIN
    Main
END Miller_f_Win.